home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Pascal Super Library
/
Pascal Super Library (CW International)(1997).bin
/
SHELLS
/
SZ2
/
GEVENT.IMP
< prev
next >
Wrap
Text File
|
1992-08-31
|
17KB
|
502 lines
{*******************************************************************
GEVENT.IMP
*******************************************************************}
{|||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||
ZOOM
|||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||}
{===================================================================
UNZOOM - shrink
===================================================================}
procedure hdUnZoom ;
{-------------------------------------------------------------------
Shrink if full size
-------------------------------------------------------------------}
procedure Action ( P : PView ) ; FAR ;
begin
if IsZoomed ( P ) then
Message ( P , evCommand , cmZoom , NIL ) ;
end ;
{- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
PROCESS
- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -}
begin
Desktop^.ForEach ( @Action ) ;
end ;
{===================================================================
ZOOM - expand
===================================================================}
procedure hdZoom ;
{-------------------------------------------------------------------
Expand if not full size
-------------------------------------------------------------------}
procedure Action ( P : PView ) ; FAR ;
begin
if not IsZoomed ( P ) then
Message ( P , evCommand , cmZoom , NIL ) ;
end ;
{- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
PROCESS
- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -}
begin
Desktop^.ForEach ( @Action ) ;
end ;
{===================================================================
ALL ZOOMED - return FALSE if any window not zoomed
===================================================================}
function AllZoomed : boolean ;
var
w : word ;
{-------------------------------------------------------------------
Is it full size?
-------------------------------------------------------------------}
procedure Action ( P : PView ) ; FAR ;
begin
if not Zoomable ( P ) then EXIT ;
if not IsZoomed ( P ) then inc ( w ) ;
end ;
{- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
PROCESS
- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -}
begin
w := 0 ;
Desktop^.ForEach ( @Action ) ;
AllZoomed := w = 0 ;
end ;
{===================================================================
ZOOM ALL
===================================================================}
procedure hdZoomAll ;
begin
if AllZoomed then
hdUnZoom
else
hdZoom ;
end ;
{|||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||
MISC
|||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||}
{===================================================================
TILE - VERTICAL (standard)
===================================================================}
procedure hdTile ;
var
R : TRect ;
begin
Desktop^.GetExtent ( R ) ;
Desktop^.Tile ( R ) ;
end ;
{===================================================================
CASCADE
===================================================================}
procedure hdCascade ;
var
R : TRect ;
begin
Desktop^.GetExtent ( R ) ;
Desktop^.Cascade ( R ) ;
end ;
{===================================================================
DIRECTORY
===================================================================}
procedure hdChangeDir ;
begin
ExecDialog ( New ( PChDirDialog ,
Init ( cdNormal , 0 ) ) , NIL ) ;
hdRefreshDisplay ;
end ;
{===================================================================
SHOW
===================================================================}
procedure hdShowClipboard ;
begin
ClipWindow^.Select ;
ClipWindow^.Show ;
end ;
{|||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||
DISPLAY
|||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||}
{===================================================================
COPY SCREEN - copy from saved buffer to the Clipboard
===================================================================}
procedure hdCopyScreen ;
var
y : byte ;
Ch : char ;
S : string ;
begin
ClipWindow^.Hide ;
VisionOFF ;
PullScreen ; { From saved buffer }
with ClipWindow^.Editor^ do
begin
SetSelect ( 0 , BufLen , TRUE ) ; { all text }
DeleteSelect ; { dump it }
for y := 1 to BiosHeight do { ROW }
begin
S := GetLine ( y , SaveScreen ) ;
S := TrimRight ( S , #32 ) ;
InsertText ( @S[1] , length ( S ) , FALSE ) ;
{- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
AVOID CR/LF ON LAST LINE
- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -}
if y < BiosHeight then
begin
Ch := #13 ;
InsertText ( @Ch , 1 , FALSE ) ; { add CR }
Ch := #10 ; { add LF }
InsertText ( @Ch , 1 , FALSE ) ;
end ;
end ;
end ;
VisionON ;
ClipWindow^.Select ;
ClipWindow^.Show ;
{- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
Goto top line
- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -}
Message ( ClipWindow , evKeyDown , kbCtrlPgUp , NIL ) ;
end ;
{===================================================================
REDRAW
===================================================================}
procedure hdRefreshDisplay ;
begin
DoneMemory ; { Dump cache buffers }
Application^.Redraw ; { Redisplay all }
end ;
{===================================================================
USER SCREEN
===================================================================}
procedure hdUserScreen ;
{-------------------------------------------------------------------
-------------------------------------------------------------------}
procedure Hide ( P : PView ) ; FAR ;
begin
P^.Hide ;
end ;
{-------------------------------------------------------------------
-------------------------------------------------------------------}
procedure Show ( P : PView ) ; FAR ;
begin
P^.Show ;
end ;
{- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
PROCESS
- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -}
var
Event : TEvent ;
begin
if SaveScreen = NIL then EXIT ;
HideMouse ;
Application^.ForEach ( @Hide ) ;
Application^.Hide ;
Message ( Application ,
evBroadcast ,
cmCommandSetChanged ,
NIL ) ;
VisionOFF ;
InitEvents ;
PullScreen ; { From saved buffer }
Application^.ClearEvent ( Event ) ;
while Event.What = evNothing do
begin
Application^.GetEvent ( Event ) ;
case Event.What of
evCommand : ;
evBroadCast : ;
evKeyDown : ;
evMouseDown : ;
else
Application^.ClearEvent ( Event ) ;
end ;
end ;
DoneEvents ;
VisionON ;
Application^.ClearEvent ( Event ) ;
Application^.ForEach ( @Show ) ;
Application^.Show ;
ShowMouse ;
hdRefreshDisplay ; { redraw screen }
Message ( Application ,
evBroadcast ,
cmCommandSetChanged ,
NIL ) ;
end ;
{|||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||
PALETTE & COLOR
|||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||}
{===================================================================
COLOR
===================================================================}
procedure hdColor ;
begin
AppPalette := apColor ;
hdRefreshDisplay ;
end ;
{===================================================================
BW
===================================================================}
procedure hdBlackWhite ;
begin
AppPalette := apBlackWhite ;
hdRefreshDisplay ;
end ;
{===================================================================
MONO
===================================================================}
procedure hdMonochrome ;
begin
AppPalette := apMonochrome ;
hdRefreshDisplay ;
end ;
{===================================================================
RESET
===================================================================}
procedure hdResetColors ;
var
SaveAppPalette : integer ;
S : string ;
begin
SaveAppPalette := AppPalette ;
AppPalette := apColor ;
S := CColor ;
Move ( S [1] , Application^.GetPalette^[1] , length ( CColor ) ) ;
AppPalette := apBlackWhite ;
S := CBlackWhite ;
Move ( S [1] , Application^.GetPalette^[1] , length ( CBlackWhite ) ) ;
AppPalette := apMonochrome ;
S := CMonochrome ;
Move ( S [1] , Application^.GetPalette^[1] , length ( CMonochrome ) ) ;
AppPalette := SaveAppPalette ;
hdRefreshDisplay ;
end ;
{===================================================================
EGA/VGA
===================================================================}
procedure hdVideoMode ;
var
NewMode : Word ;
begin
NewMode := ScreenMode xor smFont8x8;
if NewMode and smFont8x8 <> 0 then
ShadowSize.X := 1 { EGA/VGA }
else
ShadowSize.X := 2 ; { 25-line }
Application^.SetScreenMode ( NewMode ) ;
end ;
{|||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||
DESKTOP
|||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||}
{===================================================================
CLEAR - prompt first
===================================================================}
function hdClearDesktop : boolean ;
begin
hdClearDesktop := FALSE ;
if not Desktop^.Valid ( cmClose ) then EXIT ; { prompt for save }
CloseAll ; { dump'em }
ClearHistory ; { free heap }
hdClearDesktop := TRUE ;
end ;
{===================================================================
SAVE DESKTOP
===================================================================}
procedure hdSaveDesktop ;
begin
if not Desktop^.Valid ( cmClose ) then EXIT ; { prompt for save }
SaveDesktopTo ( DesktopName , 'Desktop File' ) ;
end ;
{===================================================================
LOAD DESKTOP
===================================================================}
procedure hdLoadDesktop ;
begin
if not Desktop^.Valid ( cmClose ) then EXIT ; { prompt for save }
LoadDesktopFrom ( DesktopName ) ;
end ;
{|||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||
EXEC
|||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||}
{===================================================================
EXEC - normal or Turbo Vision
===================================================================}
function VisionExec ( Path , CmdLine : string ) : word ;
var
DosScreen : boolean ;
{-------------------------------------------------------------------
MSG
-------------------------------------------------------------------}
procedure ShellMsg ;
begin
PrintStr ( #13#10 ) ;
PrintStr ( ' ▐▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▌'#13#10 ) ;
PrintStr ( ' ▐ Type EXIT to return to the program... ▌'#13#10 ) ;
PrintStr ( ' ▐▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▌'#13#10 ) ;
end ;
{-------------------------------------------------------------------
OFF
-------------------------------------------------------------------}
function AppOFF : boolean ;
begin
AppOFF := FALSE ;
if DesktopName = '' then
VisionOFF
else
begin
if not Desktop^.Valid ( cmClose ) then EXIT ;
SaveDesktopTo ( DesktopName , 'Temporary EXEC - Desktop file' ) ;
CloseAll ;
DisposeClipboard ;
ClearHistory ;
DoneHistory ;
VisionOFF ;
if BufHeapSize > 0 then
DoneBuffers ; { restore heap }
end ;
if DosScreen then
PopScreen ;
AppOFF := TRUE ;
end ;
{-------------------------------------------------------------------
ON
-------------------------------------------------------------------}
procedure AppON ;
begin
if DosScreen then
PushScreen ;
if DesktopName = '' then
VisionON
else
begin
if BufHeapSize > 0 then
InitBuffers ;
VisionON ;
InitHistory ;
LoadDesktopFrom ( DesktopName ) ;
CreateClipboard ;
end ;
end ;
{- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
PROCESS
- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -}
begin
VisionExec := $FFFF ;
DosScreen := SaveScreen <> NIL ;
if Application <> NIL then
if not AppOFF then EXIT ;
if ( Path = GetEnv ( 'COMSPEC' ) ) and ( CmdLine = '' ) then
ShellMsg ;
VisionExec := EXECPROC.Exec ( Path , CmdLine ) ;
if Application <> NIL then
AppON ;
end ;
{|||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||
SHELL - "VisionExec" saves desktop & takes care of "house cleaning"
|||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||}
{===================================================================
LITTLE - Available memory only. "DesktopName" blanked so
Desktop is not saved/loaded (avoid disk/diskette access).
===================================================================}
procedure hdLittleDOS ;
var
Temp : PathStr ;
begin
EXECPROC.UseExecSwap := FALSE ;
Temp := DesktopName ;
DesktopName := '' ;
VisionExec ( GetEnv ( 'COMSPEC' ) , '' ) ;
DesktopName := Temp ;
end ;
{===================================================================
MEDIUM - Desktop is saved, then cleared. Reloaded on return.
===================================================================}
procedure hdMediumDOS ;
begin
EXECPROC.UseExecSwap := FALSE ;
VisionExec ( GetEnv ( 'COMSPEC' ) , '' ) ;
end ;
{===================================================================
BIG - Does Swap-to-Disk/EMS. Desktop is saved & cleared, so
swap file is as small as possible.
===================================================================}
procedure hdBigDOS ;
begin
EXECPROC.UseExecSwap := TRUE ;
VisionExec ( GetEnv ( 'COMSPEC' ) , '' ) ;
end ;
{===================================================================
DOS SHELL - for simpler applications. If EXECSWAP is not used,
then "BigDOS" is the same as "MediumDOS".
===================================================================}
procedure hdDosShell ;
begin
hdBigDOS ;
end ;